CCOLUMNWIDTH

2007/2/26 Excelの列幅をピクセル単位にて設定するためのクラスモジュールを作ってみました。

■クラスモジュールCCOLUMNWIDTH

Option Explicit

'
'CCOLUMNWIDTH
'
' 列幅をピクセル単位で設定するためのクラスモジュール
'

'Win32API宣言
Private Declare Function GetDeviceCaps Lib "gdi32" _
        (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32" _
        (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDC Lib "user32" _
        (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
        (ByVal hWnd As Long, ByVal hdc As Long) As Long
'定数
Private Const LOGPIXELSX As Long = 88
Private Const POINT_PER_INCH As Long = 72 ' 1point=1/72inch
Private Const SOURCE_NAME As String = "CCOLUMNWIDTH"

Private Const ERR_1001 As Long = 1001
Private Const ERR_1001_DESCRIPTION As String = "指定されたワークブックは無効です。"
Private Const ERR_1002 As Long = 1002
Private Const ERR_1002_DESCRIPTION As String = ERR_1001_DESCRIPTION
Private Const ERR_1003 As Long = 1003
Private Const ERR_1003_DESCRIPTION As String = "ワークブックが指定されていません。"
'変数
Private WithEvents wb_ As Workbook
Private FontPixel_ As Long '標準フォントのピクセル幅
Private PaddingPixel_ As Long 'セルの余白ピクセル数
Private LogPixelsX_ As Long '解像度
'

Public Property Set Workbook(wb As Workbook)
    Set wb_ = wb

    If wb_ Is Nothing Then
        Err.Clear
        Err.Raise ERR_1001, SOURCE_NAME, ERR_1001_DESCRIPTION
    End If
    Call SetWidth(wb_)
End Property

Public Property Get FontPixel() As Long
    FontPixel = FontPixel_ '１文字あたりのピクセル数を返す。
End Property

Public Property Get PaddingPixel() As Long
    PaddingPixel = PaddingPixel_ '余白ピクセル数を返す。
End Property

Public Function GetColumnWidth(pixel As Long, Optional wb As Workbook = Nothing) As Double
    Dim ColumnWidth As Double

    'ワークブック指定されている場合は、保持しているワークブックと異なる場合はセットしなおす。
    If Not wb Is Nothing Then
        If Not wb_ Is wb Then
            Set wb_ = wb
            If Not SetWidth(wb_) Then
                Err.Clear
                Err.Raise ERR_1002, SOURCE_NAME, ERR_1002_DESCRIPTION
            End If
        End If
    End If
    'ワークブックが設定されていない場合は、エラーを発生させる。
    If wb_ Is Nothing Then
        Err.Clear
        Err.Raise ERR_1003, SOURCE_NAME, ERR_1003_DESCRIPTION
    End If
    '指定ピクセルから余白分を引いた後、１文字分の幅で割る。
    ColumnWidth = (pixel - PaddingPixel_) / FontPixel_
    GetColumnWidth = Round(ColumnWidth, 2) '小数点以下２桁とし、返す。
End Function

Private Function SetWidth(wb As Workbook) As Boolean
    Dim col1_Range As Range, col2_Range As Range
    Dim col1_Width As Long, col2_Width As Long
    Dim ws As Worksheet

    'ワークブックが指定されていない場合
    If wb_ Is Nothing Then
        SetWidth = False
        Exit Function
    End If

    Set ws = wb.Worksheets.Add '算出用にシートを追加
    With ws
        Set col1_Range = .Columns(1) '列Ａ
        Set col2_Range = .Columns(2) '列Ｂ
        col1_Range.ColumnWidth = 1 '列Ａの幅を１文字分とする
        col2_Range.ColumnWidth = 2 '列Ｂの幅を２文字分とする
        'Widthプロパティから幅（ポイント）を取得する。ピクセルに変換する。
        col1_Width = col1_Range.Cells(1, 1).Width * LogPixelsX_ / POINT_PER_INCH
        col2_Width = col2_Range.Cells(1, 1).Width * LogPixelsX_ / POINT_PER_INCH
        FontPixel_ = col2_Width - col1_Width '差分から１文字分のピクセルを算出
        PaddingPixel_ = col1_Width - FontPixel_ '余白分のピクセルを算出
    End With
    Application.DisplayAlerts = False
    ws.Delete '追加したシートを削除
    Application.DisplayAlerts = True
    SetWidth = True
End Function

Private Sub Class_Initialize()
    Dim hdc As Long

    Set wb_ = Nothing
    FontPixel_ = 0
    PaddingPixel_ = 0
    'ディスプレイより解像度を取得する。
    hdc = GetDC(0)
    LogPixelsX_ = GetDeviceCaps(hdc, LOGPIXELSX)
    Call ReleaseDC(0, hdc)
End Sub

■簡単なサンプル１

Public Sub sample1()
    Dim w As Double
    Dim wb As Workbook
    Dim ccw As New CCOLUMNWIDTH

    Set wb = Workbooks("Book1")
    w = ccw.GetColumnWidth(100, wb)
    wb.Worksheets(1).Columns(1).ColumnWidth = w
End Sub

■簡単なサンプル２

Public Sub sample2()
    Dim w As Double
    Dim wb As Workbook
    Dim ccw As New CCOLUMNWIDTH
    Dim i As Long

    Set wb = Workbooks("Book1")
    Set ccw.Workbook = wb

    For i = 1 To 5
        w = ccw.GetColumnWidth(i * 20)
        wb.Worksheets(1).Columns(i).ColumnWidth = w
    Next i
End Sub